home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Oh!X 2001 Spring
/
Oh!X 2001 Spring Special CD-ROM (Japan).7z
/
Oh!X 2001 Spring Special CD-ROM (Japan) (Track 1).bin
/
TCLTK
/
NAPON
/
napon.tcl
< prev
Wrap
Text File
|
2000-05-07
|
13KB
|
523 lines
#
# NAPON.TCL : ならべてポン!
#
# Copyright (C) 1999 by Makoto Hiroi
#
# 盤面は 4 * 4 (1 - 3),
# 5 * 5 (1 - 4),
# 6 * 6 (1 - 5),
# 外部変数
# board() : 盤面(データを格納)
# 上位 4 ビットで色、下位 4 ビットで数字を表す
# number() : テキスト ID を格納
# numstr() : 表示する文字列
# color() : 表示する色
# piece() : 図形 ID を格納
# font_type() : フォント
# size : 盤面の大きさ
# play_flag : ゲームの状態
# 0 : not play
# 1 : play
# 2 : use takeback
# buff1 : メッセージ表示用バッファ
# buff2 : 名前入力用バッファ
# time : ゲーム開始時刻
# id : after コマンドが返す固有番号
# history() : 取った牌の履歴
# move_cnt : 手数
# name() : トップテン(1 - 10, 0 is dummy)
# date()
# score()
#
# 色
set color(0) red
set color(1) blue
set color(2) green
set color(3) gold
set color(4) purple
set color(5) pink
# 数字
set numstr(0) " "
set numstr(1) "1"
set numstr(2) "2"
set numstr(3) "3"
set numstr(4) "4"
set numstr(5) "5"
# フォント
set font_type(4) "{MS ゴシック} 48"
set font_type(5) "{MS ゴシック} 36"
set font_type(6) "{MS ゴシック} 28"
# ヘルプファイルの表示
proc help {} {
global path_name
if {![winfo exist .t0]} {
toplevel .t0
wm title .t0 "NarabetePon Help"
text .t0.text -yscrollcommand ".t0.scroll set"
scrollbar .t0.scroll -command ".t0.text yview"
pack .t0.scroll -side right -fill y
pack .t0.text -side left
# ファイルの読み込み
set f [open "$path_name/NAP_HELP.TXT" r]
while {![eof $f]} {
.t0.text insert end [read $f 1000]
}
close $f
}
}
# スコアファイルリード
proc read_score_file {} {
global score_file name date score
set now_date [clock seconds]
if [file exists $score_file] {
# ファイルの読み込み
set f [open $score_file r]
foreach j {4 5 6} {
for {set i 1} {$i <= 10} {incr i} {
if {[gets $f line] < 0} {
# ダミーデータをセット
set l " \t$now_data\t5999"
}
set l [split $line "\t"]
set name($j,$i) [lindex $l 0]
set date($j,$i) [lindex $l 1]
set score($j,$i) [lindex $l 2]
}
}
close $f
} else {
# ダミーデータのセット
foreach j {4 5 6} {
for {set i 1} {$i <= 10} {incr i} {
set name($j,$i) ""
set date($j,$i) $now_date
# 5999 は 99:59 です
set score($j,$i) 5999
}
}
}
}
# スコアファイルライト
proc write_score_file {} {
global score_file name date score
set f [open $score_file w]
foreach j {4 5 6} {
for {set i 1} {$i <= 10} {incr i} {
puts $f [format "%s\t%d\t%d" $name($j,$i) $date($j,$i) $score($j,$i)]
}
}
close $f
}
# ********** スコア表示 ********
# 秒数をスコアに変換
proc change_seconds {s} {
return [format "%02d:%02d" [expr $s / 60] [expr $s % 60]]
}
#
# トップテンウィンドウを開く
#
proc open_score_window {ranking} {
global name date score size
if [winfo exists .t1] {
destroy .t1
}
toplevel .t1
wm title .t1 "Top 10"
frame .t1.f0
frame .t1.f1
label .t1.f0.l0 -text "順位 名前" -anchor w
label .t1.f1.l0 -text "記録 日付 " -anchor w
pack .t1.f0.l0 -fill x
pack .t1.f1.l0 -fill x
for {set i 1} {$i <= 10} {incr i} {
label .t1.f0.l$i -text [format "%4d %-20s" $i $name($size,$i)] -anchor w
label .t1.f1.l$i -text [format "%5s %8s" \
[change_seconds $score($size,$i)] \
[clock format $date($size,$i) -format "%y/%m/%d"]]
pack .t1.f0.l$i -fill x
pack .t1.f1.l$i -fill x
}
if {$ranking > 0} {
.t1.f0.l$ranking configure -fg red
.t1.f1.l$ranking configure -fg red
}
pack .t1.f0 .t1.f1 -side left
}
# ベストテンに入るか
proc check_hi_score {now_score} {
global score size
for {set i 1} {$i <= 10} {incr i} {
if {$score($size,$i) > $now_score} {
# ベストテンに入ったよ
return $i
}
}
return 0
}
# スコアの更新
proc update_score {n d s o} {
global name date score size
for {set i 9} {$i >= $o} {incr i -1} {
set j [expr $i + 1]
set name($size,$j) $name($size,$i)
set date($size,$j) $date($size,$i)
set score($size,$j) $score($size,$i)
}
set name($size,$o) $n
set date($size,$o) $d
set score($size,$o) $s
}
# トップテンの名前入力
proc input_hi_score_name {ranking} {
global buff2
set buff2 ""
toplevel .t2
wm title .t2 "Input Your Name"
wm geometry .t2 "+[expr [winfo x .] + 120]+[expr [winfo y .] + 180]"
label .t2.l0 -text [format "おめでとう! %d 位です" $ranking]
label .t2.l1 -text "名前を入力してね"
entry .t2.e0 -textvariable buff2
focus -force .t2.e0
grab set -global .t2
bind .t2.e0 <Return> {
# 入力チェックが必要か
if {$buff2 != ""} {
destroy .t2
}
}
pack .t2.l0 .t2.l1 .t2.e0
}
# 盤面から色を求める
proc get_color {x y} {
global board
return [expr $board($x,$y) / 16]
}
# 盤面から数字を求める
proc get_number {x y} {
global board
return [expr $board($x,$y) % 16]
}
# 完成したか
proc check_finish {} {
global size
for {set y 0} {$y < $size} {incr y} {
set c [get_color 0 $y]
set i [expr $size - 1]
for {set x 0} {$x < $i} {incr x} {
if {[get_number $x $y] != [expr $x + 1] || [get_color $x $y] != $c} {
return 0
}
}
}
return 1
}
# 手詰まりの判定
proc check_game_over {} {
global size
for {set y 0} {$y < $size} {incr y} {
if {[get_number 0 $y] == 0} {
return 0
}
}
for {set x 1} {$x < $size} {incr x} {
for {set y 0} {$y < $size} {incr y} {
if {[get_number $x $y] == 0} {
set n [get_number [expr $x - 1] $y]
if {$n != 0 && $n != [expr $size - 1]} {
return 0
}
}
}
}
return 1
}
# カードを探して右隣へ移動できるか
proc search_and_move {card} {
global board size
set i [expr $size - 1]
for {set x 0} {$x < $i} {incr x} {
for {set y 0} {$y < $size} {incr y} {
if {$board($x,$y) == $card} {
if {[get_number [expr $x + 1] $y] == 0} {
# 右隣は空いている
return [concat [expr $x + 1] $y]
}
}
}
}
return ""
}
# カードを移動できるか
proc check_move_card {x y} {
global board size
set c [get_color $x $y]
set n [get_number $x $y]
if {$n == 1} {
set y1 [expr {($x == 0) ? $y : 0}]
for {set i 0} {$i < $size} {incr i} {
if {[get_number 0 $y1] == 0} {
return [concat 0 $y1]
}
incr y1
if {$y1 == $size} {
set y1 0
}
}
} else {
return [search_and_move [expr 16 * $c + $n - 1]]
}
return ""
}
# カードの表示
proc draw_piece {x y} {
global piece number numstr color font_type size
set c [get_color $x $y]
set n [get_number $x $y]
.c0 itemconfigure $number($x,$y) -text $numstr($n) \
-fill $color($c) \
-font $font_type($size)
if {$n == 0} {
# 裏面
.c0 itemconfigure $piece($x,$y) -fill darkgreen
} else {
.c0 itemconfigure $piece($x,$y) -fill white
}
}
# カードの移動
proc move_card {x0 y0 x1 y1} {
global board
set temp $board($x0,$y0)
set board($x0,$y0) $board($x1,$y1)
set board($x1,$y1) $temp
draw_piece $x0 $y0
draw_piece $x1 $y1
}
# カードを押した時の処理
proc push_piece {x y} {
global id time play_flag buff2 move_cnt history
set pos [check_move_card $x $y]
if {$pos != ""} {
# カードの移動
eval move_card $x $y $pos
set history($move_cnt) [concat $x $y $pos]
incr move_cnt
}
if [check_finish] {
# 終了
set t [clock seconds]
set s [expr $t - $time]
after cancel $id
set ranking [check_hi_score $s]
if {$ranking > 0 && $play_flag == 1} {
input_hi_score_name $ranking
tkwait window .t2
update_score $buff2 $t $s $ranking
write_score_file
open_score_window $ranking
} else {
tk_messageBox -type ok \
-message [format "おめでとう %s です" [change_seconds $s]]
}
set play_flag 0
} elseif [check_game_over] {
after cancel $id
set play_flag 0
tk_messageBox -type ok -message "手詰まりです"
}
}
# 図形の初期化
proc init_item {} {
global piece number
# 背景
.c0 create rectangle 0 0 239 239 -fill darkgreen
# 図形の設定
for {set x 0} {$x < 6} {incr x} {
for {set y 0} {$y < 6} {incr y} {
set piece($x,$y) [.c0 create rectangle 0 0 10 10 -fill white]
set number($x,$y) [.c0 create text $x $y -text " "]
.c0 bind $piece($x,$y) <Button-1> "push_piece $x $y"
.c0 bind $number($x,$y) <Button-1> "push_piece $x $y"
.c0 lower $piece($x,$y)
.c0 lower $number($x,$y)
}
}
}
# 盤面の設定
proc make_board {} {
global board size
# piece_table は局所変数
for {set i 0; set c 0} {$c < $size} {incr c} {
for {set n 0} {$n < $size} {incr n} {
# piece_tabale の初期化
set piece_table($i) [expr $c * 16 + $n]
incr i
}
}
# 乱数でかき回す
for {set j 0} {$j < $i} {incr j} {
set n [expr int( rand() * $i )]
set temp $piece_table($n)
set piece_table($n) $piece_table($j)
set piece_table($j) $temp
}
# board にセット
set i 0
for {set y 0} {$y < $size} {incr y} {
for {set x 0} {$x < $size} {incr x} {
set board($x,$y) $piece_table($i)
incr i
}
}
}
# 図形のサイズ変更
proc change_item {} {
global piece number size
set w [expr 240 / $size]
for {set x 0} {$x < 6} {incr x} {
for {set y 0} {$y < 6} {incr y} {
if {$x < $size && $y < $size} {
set x1 [expr $x * $w]
set y1 [expr $y * $w]
set x2 [expr $x1 + $w - 1]
set y2 [expr $y1 + $w - 1]
.c0 coords $piece($x,$y) $x1 $y1 $x2 $y2
.c0 coords $number($x,$y) [expr $x1 + $w / 2] [expr $y1 + $w / 2]
} else {
.c0 lower $piece($x,$y)
.c0 lower $number($x,$y)
}
}
}
}
# 盤面の表示
proc draw_board {} {
global piece number size
for {set x 0} {$x < $size} {incr x} {
for {set y 0} {$y < $size} {incr y} {
draw_piece $x $y
.c0 raise $piece($x,$y)
.c0 raise $number($x,$y)
}
}
}
# メッセージの表示
proc display_message {} {
global time buff1
set t [expr [clock seconds] - $time]
set buff1 [format "時間 %5s" [change_seconds $t]]
}
# 時間の表示
proc display_time {} {
global id
display_message
set id [after 1000 display_time]
}
# 一手もどす
proc takeback {} {
global history move_cnt play_flag
if {$move_cnt > 0 && $play_flag > 0} {
incr move_cnt -1
set x1 [lindex $history($move_cnt) 0]
set y1 [lindex $history($move_cnt) 1]
set x2 [lindex $history($move_cnt) 2]
set y2 [lindex $history($move_cnt) 3]
move_card $x1 $y1 $x2 $y2
}
}
# ゲームの開始
proc start_game {} {
global play_flag time id move_cnt
if {$play_flag > 0} {
after cancel $id
}
while 1 {
make_board
change_item
if ![check_game_over] break
}
draw_board
set play_flag 1
set move_cnt 0
set time [clock seconds]
display_time
}
# ********** メニューの設定 **********
menu .m -type menubar
. configure -menu .m
.m add cascade -label "Games" -under 0 -menu .m.m1
.m add command -label "Takeback" -under 0 -command "takeback"
.m add cascade -label "Size" -under 0 -menu .m.m2
.m add command -label "Help" -under 0 -command "help"
menu .m.m1 -tearoff no
.m.m1 add command -label "Start" -under 0 -command "start_game"
.m.m1 add command -label "HiScore" -under 0 -command "open_score_window 0"
.m.m1 add separator
.m.m1 add command -label "Exit" -under 0 -command "exit"
menu .m.m2 -tearoff no
.m.m2 add radiobutton -label "4 * 4" -variable size -value 4 -command "start_game"
.m.m2 add radiobutton -label "5 * 5" -variable size -value 5 -command "start_game"
.m.m2 add radiobutton -label "6 * 6" -variable size -value 6 -command "start_game"
# オプションの設定
option add *font "{MS ゴシック} 12"
# 画面の設定 (240 * 240) 60, 48, 40
canvas .c0 -width 240 -height 240
# 表示用ラベル
label .l1 -textvariable buff1 -bg darkgreen -fg white -anchor e
pack .l1 .c0 -fill x
# 窓の題名
wm title . "NarabetePon"
wm resizable . 0 0
# 初期化
set play_flag 0
set size 4
set path_name [file dirname $argv0]
set score_file "$path_name/NAPON.SCO"
init_item
# スコアファイルのリード
read_score_file
focus -force .
# end of file